home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
PC World Interactive 7
/
PC World Interactive 7.iso
/
program
/
pasprog.EXE
/
GIFUTIL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-10-10
|
22KB
|
545 lines
unit GifUtil;
{ GifUtl.pas - (c)Copyright 1993 Sean Wenzel
Users are given the right to use/modify and distribute this source code as
long as credit is given where due. I would also ask that anyone who makes
use of this source/program drop me a line at my CompuServe address of
71736,1245. Just curious...
The unit was written using Borland Pascal v7.0 but I think it should work
with Turbo Pascal down to 5.5 at the most (or least?).
This unit has only been tested on my system - an Everex Tempo 386DX
with its built in SVGA adapter. If anyone finds/fixes any bugs please
let me know. (Feel free to send a copy of any code too)
I have also only tested 3 or 4 256,16, and 2 color interlaced and non-
interlaced images. (was enough for my needs)
Some of the code is very loosely based on DECODER.C (availble online)
so credit should be given to Steven A. Bennett and Steve Wilhite
The unit is set up to use BGI256.BGI (inlcuded) which is available on CIS
in the BPASCAL forum library. The graphics initialization tries to start
up in 640 by 480 mode. If an error occurs it'll go down to 320x200
automatically (well - it should). For higher res modes change the variable
GraphMode in the InitGraphics procedure to 3 for 800x600 and 4 for 1024x768.
A sample program (GIF.PAS) is provided to demostrate the use of this unit.
Basically declare a pointer to the TGIF object then initialize it using a
line such as TheGif := New(PGif, Init('agif')); You can then check
TheGif^.Status for any errors and/or view the GIF headers and ColorTables.
To switch to Graphics mode and show the GIF image use TheGif^.Decode(True)
True tells it to beep when done(or boop if some sort of error occured).
When finished use Dispose(TheGif, Done) to switch back to textmode and get
rid of the object.
If anyone cares to speed up the image decoding I'd suggest writing
TGIF.NextCode in assembler. The routine is the most heavily called in the
unit while decoding and on my sytem took up about 5 seconds out of 12 when
I profiled it. (send me a copy if you can)
I have practically commented every line so that the source should be very
readable and easy to follow. Great for learning about GIF's and LZW
decompression.
Any problems or suggestions drop me a line
Good luck...
-Sean
(almost forgot)
"The Graphics Interchange Format(c) is the Copyright property of
CompuServe Incorporated. GIF(sm) is a Service Mark property of
CompuServe Incorporated."
}
{$R-} { range checking off } { Put them on if you like but it slows down the}
{$S-} { stack checking off } { decoding (almost doubles it!) }
{$I-} { i/o checking off }
interface
uses Objects;
type
TDataSubBlock = record
Size: byte; { size of the block -- 0 to 255 }
Data: array[1..255] of byte; { the data }
end;
const
BlockTerminator: byte = 0; { terminates stream of data blocks }
type
THeader = record
Signature: array[0..2] of char; { contains 'GIF' }
Version: array[0..2] of char; { '87a' or '89a' }
end;
TLogicalScreenDescriptor = record
ScreenWidth: word; { logical screen width }
ScreenHeight: word; { logical screen height }
PackedFields: byte; { packed fields - see below }
BackGroundColorIndex: byte; { index to global color table }
AspectRatio: byte; { actual ratio = (AspectRatio + 15) / 64 }
end;
const
{ logical screen descriptor packed field masks }
lsdGlobalColorTable = $80; { set if global color table follows L.S.D. }
lsdColorResolution = $70; { Color resolution - 3 bits }
lsdSort = $08; { set if global color table is sorted - 1 bit }
lsdColorTableSize = $07; { size of global color table - 3 bits }
{ Actual size = 2^value+1 - value is 3 bits }
type
TColorItem = record { one item a a color table }
Red: byte;
Green: byte;
Blue: byte;
end;
TColorTable = array[0..255] of TColorItem; { the color table }
const
ImageSeperator: byte = $2C;
type
TImageDescriptor = record
Seperator: byte; { fixed value of ImageSeperator }
ImageLeftPos: word; {Column in pixels in respect to left edge of logical screen }
ImageTopPos: word;{row in pixels in respect to top of logical screen }
ImageWidth: word; { width of image in pixels }
ImageHeight: word; { height of image in pixels }
PackedFields: byte; { see below }
end;
const
{ image descriptor bit masks }
idLocalColorTable = $80; { set if a local color table follows }
idInterlaced = $40; { set if image is interlaced }
idSort = $20; { set if color table is sorted }
idReserved = $0C; { reserved - must be set to $00 }
idColorTableSize = $07; { size of color table as above }
Trailer: byte = $3B; { indicates the end of the GIF data stream }
{ other extension blocks not currently supported by this unit
- Graphic Control extension
- Comment extension I'm not sure what will happen if these blocks
- Plain text extension are encountered but it'll be interesting
- application extension }
const
ExtensionIntroducer: byte = $21;
MAXSCREENWIDTH = 800;
type
TExtensionBlock = record
Introducer: byte; { fixed value of ExtensionIntroducer }
ExtensionLabel: byte;
BlockSize: byte;
end;
PCodeItem = ^TCodeItem;
TCodeItem = record
Code1, Code2: byte;
end;
const
MAXCODES = 4095; { the maximum number of different codes 0 inclusive }
type
{ This is the actual gif object }
PGif = ^TGif;
TGif = object(TObject)
Stream: PBufStream; { the file stream for the gif file }
Header: THeader; { gif file header }
LogicalScreen: TLogicalScreenDescriptor; { gif screen descriptor }
GlobalColorTable: TColorTable; { global color table }
LocalColorTable: TColorTable; { local color table }
ImageDescriptor: TImageDescriptor; { image descriptor }
UseLocalColors: boolean; { true if local colors in use }
Interlaced: boolean; { true if image is interlaced }
LZWCodeSize: byte; { minimum size of the LZW codes in bits }
ImageData: TDataSubBlock; { variable to store incoming gif data }
TableSize: word; { number of entrys in the color table }
BitsLeft, BytesLeft: integer;{ bits left in byte - bytes left in block }
BadCodeCount: word; { bad code counter }
CurrCodeSize: integer; { Current size of code in bits }
ClearCode: integer; { Clear code value }
EndingCode: integer; { ending code value }
Slot: word; { position that the next new code is to be added }
TopSlot: word; { highest slot position for the current code size }
HighCode: word; { highest code that does not require decoding }
NextByte: integer; { the index to the next byte in the datablock array }
CurrByte: byte; { the current byte }
DecodeStack: array[0..MAXCODES] of byte; { stack for the decoded codes }
Prefix: array[0..MAXCODES] of word; { array for code prefixes }
Suffix: array[0..MAXCODES] of byte; { array for code suffixes }
LineBuffer: array[0..MAXSCREENWIDTH] of byte; { array for buffer line output }
CurrentX, CurrentY: integer; { current screen locations }
Status: word; { status of the decode }
InterlacePass: byte; { interlace pass number }
constructor Init(AGIFName: string);
destructor Done; virtual;
procedure Error(What: integer);
procedure InitCompressionStream; { initializes info for decode }
procedure ReadSubBlock; { reads a data subblock from the stream }
function NextCode: word; { returns the next available code }
procedure Decode(Beep: boolean); { the actual LZW decoding routine }
procedure DrawLine; { writes the drawline buffer to screen }
procedure InitGraphics; { Initializes Graphics mode }
end;
const
{ error constants }
geNoError = 0; { no errors found }
geNoFile = 1; { gif file not found }
geNotGIF = 2; { file is not a gif file }
geNoGlobalColor = 3; { no Global Color table found }
geImagePreceded = 4; { image descriptor preceeded by other unknown data }
geEmptyBlock = 5; { Block has no data }
geUnExpectedEOF = 6; { unexpected EOF }
geBadCodeSize = 7; { bad code size }
geBadCode = 8; { Bad code was found }
geBitSizeOverflow = 9; { bit size went beyond 12 bits }
implementation
uses Graph, Crt;
function Power(A, N: real): real; { returns A raised to the power of N }
begin
Power := exp(N * ln(A));
end;
{ TGif }
constructor TGif.Init(AGIFName: string);
begin
inherited Init;
if Pos('.',AGifName) = 0 then { if the filename has no extension add one }
AGifName := AGifName + '.gif';
Stream := New(PBufStream, Init(AGifName, stOpen, 2048));
Stream^.Read(Header, sizeof(Header)); { read the header }
if Header.Signature <> 'GIF' then Error(geNotGIF); { is vaild signature }
Stream^.Read(LogicalScreen, sizeof(LogicalScreen));
if LogicalScreen.PackedFields and lsdGlobalColorTable = lsdGlobalColorTable then
begin
TableSize := trunc(Power(2,(LogicalScreen.PackedFields and lsdColorTableSize)+1));
Stream^.Read(GlobalColorTable, TableSize*sizeof(TColorItem)); { read Global Color Table }
end
else
Error(geNoGlobalColor);
Stream^.Read(ImageDescriptor, sizeof(ImageDescriptor)); { read image descriptor }
if ImageDescriptor.Seperator <> ImageSeperator then { verify that it is the descriptor }
Error(geImagePreceded);
if ImageDescriptor.PackedFields and idLocalColorTable = idLocalColorTable then
begin { if local color table }
TableSize := trunc(Power(2,(ImageDescriptor.PackedFields and idColorTableSize)+1));
Stream^.Read(LocalColorTable, TableSize*sizeof(TColorItem)); { read Local Color Table }
UseLocalColors := True;
end
else
UseLocalColors := false;
if ImageDescriptor.PackedFields and idInterlaced = idInterlaced then
begin
Interlaced := true;
InterlacePass := 0;
end;
if (Stream = nil) or (Stream^.Status <> stOk) then{ check for stream error }
Error(geNoFile);
Status := 0;
end;
destructor TGif.Done;
begin
CloseGraph;
TextMode(LastMode);
if Stream <> nil then
Dispose(Stream, Done);
inherited Done;
end;
procedure TGif.Error(What: integer);
begin
Status := What;
end;
procedure TGif.InitCompressionStream;
var
I: integer;
begin
InitGraphics; { Initialize the graphics display }
Stream^.Read(LZWCodeSize, sizeof(byte));{ get minimum code size }
if not (LZWCodeSize in [2..9]) then { valid code sizes 2-9 bits }
Error(geBadCodeSize);
CurrCodeSize := succ(LZWCodeSize); { set the initial code size }
ClearCode := 1 shl LZWCodeSize; { set the clear code }
EndingCode := succ(ClearCode); { set the ending code }
HighCode := pred(ClearCode); { set the highest code not needing decoding }
BytesLeft := 0; { clear other variables }
BitsLeft := 0;
CurrentX := 0;
CurrentY := 0;
end;
procedure TGif.ReadSubBlock;
begin
Stream^.Read(ImageData.Size, sizeof(ImageData.Size)); { get the data block size }
if ImageData.Size = 0 then Error(geEmptyBlock); { check for empty block }
Stream^.Read(ImageData.Data, ImageData.Size); { read in the block }
NextByte := 1; { reset next byte }
BytesLeft := ImageData.Size; { reset bytes left }
end;
const
CodeMask: array[0..12] of longint = ( { bit masks for use with Next code }
0,
$0001, $0003,
$0007, $000F,
$001F, $003F,
$007F, $00FF,
$01FF, $03FF,
$07FF, $0FFF);
function TGif.NextCode: word; { returns a code of the proper bit size }
var
Ret: longint; { temporary return value }
begin
if BitsLeft = 0 then { any bits left in byte ? }
begin { any bytes left }
if BytesLeft <= 0 then { if not get another block }
ReadSubBlock;
CurrByte := ImageData.Data[NextByte]; { get a byte }
inc(NextByte); { set the next byte index }
BitsLeft := 8; { set bits left in the byte }
dec(BytesLeft); { decrement the bytes left counter }
end;
ret := CurrByte shr (8 - BitsLeft); { shift off any previosly used bits}
while CurrCodeSize > BitsLeft do { need more bits ? }
begin
if BytesLeft <= 0 then { any bytes left in block ? }
ReadSubBlock; { if not read in another block }
CurrByte := ImageData.Data[NextByte]; { get another byte }
inc(NextByte); { increment NextByte counter }
ret := ret or (CurrByte shl BitsLeft);{ add the remaining bits to the return value }
BitsLeft := BitsLeft + 8; { set bit counter }
dec(BytesLeft); { decrement bytesleft counter }
end;
BitsLeft := BitsLeft - CurrCodeSize; { subtract the code size from bitsleft }
ret := ret and CodeMask[CurrCodeSize];{ mask off the right number of bits }
NextCode := ret;
end;
{ this procedure initializes the graphics mode and actually decodes the
GIF image }
procedure TGif.Decode(Beep: boolean);
var
SP: integer; { index to the decode stack }
{ local procedure that decodes a code and puts it on the decode stack }
procedure DecodeCode(var Code: word);
begin
while Code > HighCode do { rip thru the prefix list placing suffixes }
begin { onto the decode stack }
DecodeStack[SP] := Suffix[Code]; { put the suffix on the decode stack }
inc(SP); { increment decode stack index }
Code := Prefix[Code]; { get the new prefix }
end;
DecodeStack[SP] := Code; { put the last code onto the decode stack }
inc(SP); { increment the decode stack index }
end;
var
TempOldCode, OldCode: word;
BufCnt: word; { line buffer counter }
Code, C: word;
CurrBuf: word; { line buffer index }
begin
InitGraphics; { Initialize the graphics mode and RGB palette }
InitCompressionStream; { Initialize decoding paramaters }
OldCode := 0;
SP := 0;
BufCnt := ImageDescriptor.ImageWidth; { set the Image Width }
CurrBuf := 0;
C := NextCode; { get the initial code - should be a clear code }
while C <> EndingCode do { main loop until ending code is found }
begin
if C = ClearCode then { code is a clear code - so clear }
begin
CurrCodeSize := LZWCodeSize + 1;{ reset the code size }
Slot := EndingCode + 1; { set slot for next new code }
TopSlot := 1 shl CurrCodeSize; { set max slot number }
while C = ClearCode do
C := NextCode; { read until all clear codes gone - shouldn't happen }
if C = EndingCode then
begin
Error(geBadCode); { ending code after a clear code }
break; { this also should never happen }
end;
if C >= Slot { if the code is beyond preset codes then set to zero }
then c := 0;
OldCode := C;
DecodeStack[sp] := C; { output code to decoded stack }
inc(SP); { increment decode stack index }
end
else { the code is not a clear code or an ending code so it must }
begin { be a code code - so decode the code }
Code := C;
if Code < Slot then { is the code in the table? }
begin
DecodeCode(Code); { decode the code }
if Slot <= TopSlot then
begin { add the new code to the table }
Suffix[Slot] := Code; { make the suffix }
PreFix[slot] := OldCode; { the previous code - a link to the data }
inc(Slot); { increment slot number }
OldCode := C; { set oldcode }
end;
if Slot >= TopSlot then { have reached the top slot for bit size }
begin { increment code bit size }
if CurrCodeSize < 12 then { new bit size not too big? }
begin
TopSlot := TopSlot shl 1; { new top slot }
inc(CurrCodeSize) { new code size }
end
else
Error(geBitSizeOverflow); { encoder made a boo boo }
end;
end
else
begin { the code is not in the table }
if Code <> Slot then { code is not the next available slot }
Error(geBadCode); { so error out }
{ the code does not exist so make a new entry in the code table
and then translate the new code }
TempOldCode := OldCode; { make a copy of the old code }
while OldCode > HighCode do { translate the old code and place it }
begin { on the decode stack }
DecodeStack[SP] := Suffix[OldCode]; { do the suffix }
OldCode := Prefix[OldCode]; { get next prefix }
end;
DecodeStack[SP] := OldCode; { put the code onto the decode stack }
{ but DO NOT increment stack index }
{ the decode stack is not incremented because because we are only
translating the oldcode to get the first character }
if Slot <= TopSlot then
begin { make new code entry }
Suffix[Slot] := OldCode; { first char of old code }
Prefix[Slot] := TempOldCode; { link to the old code prefix }
inc(Slot); { increment slot }
end;
if Slot >= TopSlot then { slot is too big }
begin { increment code size }
if CurrCodeSize < 12 then
begin
TopSlot := TopSlot shl 1; { new top slot }
inc(CurrCodeSize) { new code size }
end
else
Error(geBitSizeOverFlow);
end;
DecodeCode(Code); { now that the table entry exists decode it }
OldCode := C; { set the new old code }
end;
end;
{ the decoded string is on the decode stack so pop it off and put it
into the line buffer }
while SP > 0 do
begin
dec(SP);
LineBuffer[CurrBuf] := DecodeStack[SP];
inc(CurrBuf);
dec(BufCnt);
if BufCnt = 0 then { is the line full ? }
begin
DrawLine;
CurrBuf := 0;
BufCnt := ImageDescriptor.ImageWidth;
end;
end;
C := NextCode; { get the next code and go at is some more }
end; { now that wasn't all that bad was it? }
if Beep then
if Status = 0 then
begin
Sound(660); { Beep if status is ok }
Delay(50);
NoSound;
end
else
begin
Sound(110); { Boop if status is not ok }
Delay(200);
NoSound;
end;
end;
procedure TGif.DrawLine;
var
I: integer;
begin
for I := 0 to ImageDescriptor.ImageWidth do
PutPixel(I, CurrentY, LineBuffer[I]);
inc(CurrentY);
if InterLaced then { Interlace support }
begin
case InterlacePass of
0: CurrentY := CurrentY + 7;
1: CurrentY := CurrentY + 7;
2: CurrentY := CurrentY + 3;
3: CurrentY := CurrentY + 1;
end;
if CurrentY >= ImageDescriptor.ImageHeight then
begin
inc(InterLacePass);
case InterLacePass of
1: CurrentY := 4;
2: CurrentY := 2;
3: CurrentY := 1;
end;
end;
end;
end;
procedure TGif.InitGraphics;
var
GraphDriver: integer;
GraphMode: integer;
ErrorCode: integer;
I: integer;
begin
GraphDriver := InstallUserDriver('bgi256', nil);
GraphMode := 2;
InitGraph(GraphDriver, GraphMode, '\dealer\bin');
ErrorCode := GraphResult;
if ErrorCode <> grOk then
begin
Writeln('Graphics Error: ', GraphErrorMsg(ErrorCode));
Halt(99);
end;
{ the following loop sets up the RGB palette }
if not UseLocalColors then
for I := 0 to TableSize - 1 do
SetRGBPalette(I, GlobalColorTable[I].Red div 4, GlobalColorTable[i].Green
div 4, GlobalColorTable[I].Blue div 4)
else
for I := 0 to TableSize - 1 do
SetRGBPalette(I, LocalColorTable[I].Red div 4, LocalColorTable[i].Green
div 4, LocalColorTable[I].Blue div 4);
end;
end.